home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / break.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  152 lines
  1. ;;;; "break.scm" Breakpoints for debugging in Scheme.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'qp)
  21.  
  22. ;;;; BREAKPOINTS
  23.  
  24. ;;; Typing (init-debug) at top level sets up a continuation for
  25. ;;; breakpoint.  When (breakpoint arg1 ...) is then called it returns
  26. ;;; from the top level continuation and pushes the continuation from
  27. ;;; which it was called on breakpoint:continuation-stack.  If
  28. ;;; (continue) is later called, it pops the topmost continuation off
  29. ;;; of breakpoint:continuation-stack and returns #f to it.
  30.  
  31. (define breakpoint:continuation-stack '())
  32.  
  33. (define debug:breakpoint
  34.   (let ((call-with-current-continuation call-with-current-continuation)
  35.     (apply apply) (qpn qpn)
  36.     (cons cons) (length length))
  37.     (lambda args
  38.       (apply qpn "BREAKPOINT:" args)
  39.       (let ((ans
  40.          (call-with-current-continuation
  41.           (lambda (x)
  42.         (set! breakpoint:continuation-stack
  43.               (cons x breakpoint:continuation-stack))
  44.         (debug:top-continuation
  45.          (length breakpoint:continuation-stack))))))
  46.     (cond ((not (eq? ans breakpoint:continuation-stack)) ans))))))
  47.  
  48. (define debug:continue
  49.   (let ((null? null?) (car car) (cdr cdr))
  50.     (lambda args
  51.       (cond ((null? breakpoint:continuation-stack)
  52.          (display "; no break to continue from")
  53.          (newline))
  54.         (else
  55.          (let ((cont (car breakpoint:continuation-stack)))
  56.            (set! breakpoint:continuation-stack
  57.              (cdr breakpoint:continuation-stack))
  58.            (if (null? args) (cont #f)
  59.            (apply cont args))))))))
  60.  
  61. (define debug:top-continuation
  62.   (if (provided? 'abort)
  63.       (lambda (val) (display val) (newline) (abort))
  64.       (begin (display "; type (init-debug)") #f)))
  65.  
  66. (define (init-debug)
  67.   (call-with-current-continuation
  68.    (lambda (x) (set! debug:top-continuation x))))
  69.  
  70. (define breakpoint debug:breakpoint)
  71. (define bkpt debug:breakpoint)
  72. (define continue debug:continue)
  73.  
  74. (define debug:breakf
  75.   (let ((null? null?)            ;These bindings are so that
  76.     (not not)            ;breakf will not break on parts
  77.     (car car) (cdr cdr)        ;of itself.
  78.     (eq? eq?) (+ +) (zero? zero?) (modulo modulo)
  79.     (apply apply) (display display) (breakpoint debug:breakpoint))
  80.     (lambda (function . optname)
  81. ;;;      (set! debug:indent 0)
  82.       (let ((name (if (null? optname) function (car optname))))
  83.     (lambda args
  84.       (cond ((and (not (null? args))
  85.               (eq? (car args) 'debug:unbreak-object)
  86.               (null? (cdr args)))
  87.          function)
  88.         (else
  89.          (breakpoint name args)
  90.          (apply function args))))))))
  91.  
  92. ;;; the reason I use a symbol for debug:unbreak-object is so
  93. ;;; that functions can still be unbreaked if this file is read in twice.
  94.  
  95. (define (debug:unbreakf function)
  96. ;;;  (set! debug:indent 0)
  97.   (function 'debug:unbreak-object))
  98.  
  99. ;;;;The break: functions wrap around the debug: functions to provide
  100. ;;; niceties like keeping track of breakd functions and dealing with
  101. ;;; redefinition.
  102.  
  103. (require 'alist)
  104. (define break:adder (alist-associator eq?))
  105. (define break:deler (alist-remover eq?))
  106.  
  107. (define *breakd-procedures* '())
  108. (define (break:breakf fun sym)
  109.   (cond ((not (procedure? fun))
  110.      (display "WARNING: not a procedure " (current-error-port))
  111.      (display sym (current-error-port))
  112.      (newline (current-error-port))
  113.      (set! *breakd-procedures* (break:deler *breakd-procedures* sym))
  114.      fun)
  115.     (else
  116.      (let ((p (assq sym *breakd-procedures*)))
  117.        (cond ((and p (eq? (cdr p) fun))
  118.           fun)
  119.          (else
  120.           (let ((tfun (debug:breakf fun sym)))
  121.             (set! *breakd-procedures*
  122.               (break:adder *breakd-procedures* sym tfun))
  123.             tfun)))))))
  124.  
  125. (define (break:unbreakf fun sym)
  126.   (let ((p (assq sym *breakd-procedures*)))
  127.     (set! *breakd-procedures* (break:deler *breakd-procedures* sym))
  128.     (cond ((not (procedure? fun)) fun)
  129.       ((not p) fun)
  130.       ((eq? (cdr p) fun)
  131.        (debug:unbreakf fun))
  132.       (else fun))))
  133.  
  134. (define breakf debug:breakf)
  135. (define unbreakf debug:unbreakf)
  136.  
  137. ;;;; Finally, the macros break and unbreak
  138.  
  139. (defmacro break xs
  140.   (if (null? xs)
  141.       `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x)))
  142.              (map car *breakd-procedures*))
  143.           (map car *breakd-procedures*))
  144.       `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) xs))))
  145. (defmacro unbreak xs
  146.   (if (null? xs)
  147.       (slib:eval
  148.        `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x)))
  149.               (map car *breakd-procedures*))
  150.            '',(map car *breakd-procedures*)))
  151.       `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) xs))))
  152.